home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / gc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-17  |  21.3 KB  |  985 lines
  1. /*    Copyright (C) 1995 Free Software Foundation, Inc.
  2.  * 
  3.  * This program is free software; you can redistribute it and/or modify
  4.  * it under the terms of the GNU General Public License as published by
  5.  * the Free Software Foundation; either version 2, or (at your option)
  6.  * any later version.
  7.  * 
  8.  * This program is distributed in the hope that it will be useful,
  9.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.  * GNU General Public License for more details.
  12.  * 
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with this software; see the file COPYING.  If not, write to
  15.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  *
  17.  * As a special exception, the Free Software Foundation gives permission
  18.  * for additional uses of the text contained in its release of GUILE.
  19.  *
  20.  * The exception is that, if you link the GUILE library with other files
  21.  * to produce an executable, this does not by itself cause the
  22.  * resulting executable to be covered by the GNU General Public License.
  23.  * Your use of that executable is in no way restricted on account of
  24.  * linking the GUILE library code into it.
  25.  *
  26.  * This exception does not however invalidate any other reasons why
  27.  * the executable file might be covered by the GNU General Public License.
  28.  *
  29.  * This exception applies only to the code released by the
  30.  * Free Software Foundation under the name GUILE.  If you copy
  31.  * code from other Free Software Foundation releases into a copy of
  32.  * GUILE, as the General Public License permits, the exception does
  33.  * not apply to the code that you add in this way.  To avoid misleading
  34.  * anyone as to the status of such modified files, you must delete
  35.  * this exception notice from them.
  36.  *
  37.  * If you write modifications of your own for GUILE, it is your choice
  38.  * whether to permit this exception to apply to your modifications.
  39.  * If you do not wish that, delete this exception notice.  
  40.  */
  41.  
  42.  
  43. #include <stdio.h>
  44. #include "_scm.h"
  45.  
  46.  
  47.  
  48. SCM scm_sys_protects[NUM_PROTECTS];
  49. sizet scm_num_protects = NUM_PROTECTS;
  50.  
  51. /* If fewer than MIN_GC_YIELD cells are recovered during a garbage
  52.  * collection (GC) more space is allocated for the heap.
  53.  */
  54. #define MIN_GC_YIELD (scm_heap_size/4)
  55.  
  56.  
  57.  
  58.  
  59. /* {Front end to malloc}
  60.  *
  61.  * scm_must_malloc, scm_must_realloc, scm_must_free
  62.  *
  63.  * These functions provide services comperable to malloc, realloc, and
  64.  * free.  They are for allocating malloced parts of scheme objects.
  65.  * The primary purpose of the front end is to impose calls to gc.
  66.  */
  67.  
  68. /* scm_mtrigger
  69.  * is the number of bytes of must_malloc allocation needed to trigger gc.
  70.  */
  71. long scm_mtrigger;
  72.  
  73. /* scm_grew_lim
  74.  * is called whenever the must_malloc limit that triggers garbage collection
  75.  * is raised.  The limit is raised if a garbage collection followed
  76.  * by a subsequent allocation fails to reduce allocated storage below
  77.  * the limit.
  78.  */
  79. #ifdef __STDC__
  80. void 
  81. scm_grew_lim (long nm)
  82. #else
  83. void 
  84. scm_grew_lim (nm)
  85.      long nm;
  86. #endif
  87. {
  88.   ALLOW_INTS;
  89.   scm_growth_mon ("limit", nm, "bytes");
  90.   DEFER_INTS;
  91. }
  92.  
  93. /* scm_must_malloc
  94.  * Return newly malloced storage or throw an error.
  95.  *
  96.  * The parameter WHAT is a string for error reporting.
  97.  * If the threshold scm_mtrigger will be passed by this 
  98.  * allocation, or if the first call to malloc fails,
  99.  * garbage collect -- on the presumption that some objects
  100.  * using malloced storage may be collected.
  101.  *
  102.  * The limit scm_mtrigger may be raised by this allocation.
  103.  */
  104. #ifdef __STDC__
  105. char *
  106. scm_must_malloc (long len, char *what)
  107. #else
  108. char *
  109. scm_must_malloc (len, what)
  110.      long len;
  111.      char *what;
  112. #endif
  113. {
  114.   char *ptr;
  115.   sizet size = len;
  116.   long nm = scm_mallocated + size;
  117.   if (len != size)
  118.   malerr:
  119.     scm_wta (MAKINUM (len), (char *) NALLOC, what);
  120.   if ((nm <= scm_mtrigger))
  121.     {
  122.       SYSCALL (ptr = (char *) malloc (size));
  123.       if (NULL != ptr)
  124.     {
  125.       scm_mallocated = nm;
  126.       return ptr;
  127.     }
  128.     }
  129.   scm_igc (what);
  130.   nm = scm_mallocated + size;
  131.   if (nm > scm_mtrigger)
  132.     scm_grew_lim (nm + nm / 2);    /* must do before malloc */
  133.   SYSCALL (ptr = (char *) malloc (size));
  134.   if (NULL != ptr)
  135.     {
  136.       scm_mallocated = nm;
  137.       if (nm > scm_mtrigger)
  138.     scm_mtrigger = nm + nm / 2;
  139.       return ptr;
  140.     }
  141.   goto malerr;
  142. }
  143.  
  144.  
  145. /* scm_must_realloc
  146.  * is similar to scm_must_malloc.
  147.  */
  148. #ifdef __STDC__
  149. char *
  150. scm_must_realloc (char *where, long olen, long len, char *what)
  151. #else
  152. char *
  153. scm_must_realloc (where, olen, len, what)
  154.      char *where;
  155.      long olen;
  156.      long len;
  157.      char *what;
  158. #endif
  159. {
  160.   char *ptr;
  161.   sizet size = len;
  162.   long nm = scm_mallocated + size - olen;
  163.   if (len != size)
  164.   ralerr:
  165.     scm_wta (MAKINUM (len), (char *) NALLOC, what);
  166.   if ((nm <= scm_mtrigger))
  167.     {
  168.       SYSCALL (ptr = (char *) realloc (where, size));
  169.       if (NULL != ptr)
  170.     {
  171.       scm_mallocated = nm;
  172.       return ptr;
  173.     }
  174.     }
  175.   scm_igc (what);
  176.   nm = scm_mallocated + size - olen;
  177.   if (nm > scm_mtrigger)
  178.     scm_grew_lim (nm + nm / 2);    /* must do before realloc */
  179.   SYSCALL (ptr = (char *) realloc (where, size));
  180.   if (NULL != ptr)
  181.     {
  182.       scm_mallocated = nm;
  183.       if (nm > scm_mtrigger)
  184.     scm_mtrigger = nm + nm / 2;
  185.       return ptr;
  186.     }
  187.   goto ralerr;
  188. }
  189.  
  190. /* scm_must_free
  191.  * is for releasing memory from scm_must_realloc and scm_must_malloc.
  192.  */
  193. #ifdef __STDC__
  194. void 
  195. scm_must_free (char *obj)
  196. #else
  197. void 
  198. scm_must_free (obj)
  199.      char *obj;
  200. #endif
  201. {
  202.   if (obj)
  203.     free (obj);
  204.   else
  205.     scm_wta (INUM0, "already free", "");
  206. }
  207.  
  208.  
  209.  
  210.  
  211. /* {Heap Segments}
  212.  *
  213.  * Each heap segment is an array of objects of a particular size.
  214.  * Every segment has an associated (possibly shared) freelist.
  215.  * A table of segment records is kept that records the upper and
  216.  * lower extents of the segment;  this is used during the conservative
  217.  * phase of gc to identify probably gc roots (because they point
  218.  * into valid segments at reasonable offsets).
  219.  */
  220.  
  221. /* scm_expmem
  222.  * is true if the first segment was smaller than INIT_HEAP_SEG.
  223.  * If scm_expmem is set to one, subsequent segment allocations will
  224.  * allocate segments of size EXPHEAP(scm_heap_size).
  225.  */
  226. int scm_expmem = 0;
  227.  
  228. /* scm_heap_org
  229.  * is the lowest base address of any heap segment.
  230.  */
  231. CELLPTR scm_heap_org;
  232.  
  233. struct scm_heap_seg_data * scm_heap_table = 0;
  234. int scm_n_heap_segs = 0;
  235.  
  236. /* scm_heap_size
  237.  * is the total number of cells in heap segments.
  238.  */
  239. long scm_heap_size = 0;
  240.  
  241. /* init_heap_seg
  242.  * initializes a new heap segment and return the number of objects it contains.
  243.  *
  244.  * The segment origin, segment size in bytes, and the span of objects
  245.  * in cells are input parameters.  The freelist is both input and output.
  246.  *
  247.  * This function presume that the scm_heap_table has already been expanded
  248.  * to accomodate a new segment record.
  249.  */
  250.  
  251.  
  252. #ifdef __STDC__
  253. static sizet 
  254. init_heap_seg (CELLPTR seg_org, sizet size, int ncells, SCM *freelistp)
  255. #else
  256. static sizet 
  257. init_heap_seg (seg_org, size, ncells, freelistp)
  258.      CELLPTR seg_org;
  259.      sizet size;
  260.      int ncells;
  261.      SCM *freelistp;
  262. #endif
  263. {
  264.   register CELLPTR ptr;
  265. #ifdef POINTERS_MUNGED
  266.   register SCM scmptr;
  267. #else
  268. #define scmptr ptr
  269. #endif
  270.   CELLPTR seg_end;
  271.   sizet new_seg_index;
  272.   sizet n_new_objects;
  273.   
  274.   if (seg_org == NULL)
  275.     return 0;
  276.  
  277.   ptr = seg_org;
  278.  
  279.   /* Compute the ceiling on valid object pointers w/in this segment. 
  280.    */
  281.   seg_end = CELL_DN ((char *) ptr + size);
  282.  
  283.   /* Find the right place and insert the segment record. 
  284.    *
  285.    */
  286.   for (new_seg_index = 0;
  287.        (   (new_seg_index < scm_n_heap_segs)
  288.     && PTR_LE (scm_heap_table[new_seg_index].bounds[0], seg_org));
  289.        new_seg_index++)
  290.     ;
  291.  
  292.   {
  293.     int i;
  294.     for (i = scm_n_heap_segs; i > new_seg_index; --i)
  295.       scm_heap_table[i] = scm_heap_table[i - 1];
  296.   }
  297.   
  298.   ++scm_n_heap_segs;
  299.  
  300.   scm_heap_table[new_seg_index].valid = 0;
  301.   scm_heap_table[new_seg_index].ncells = ncells;
  302.   scm_heap_table[new_seg_index].freelistp = freelistp;
  303.   scm_heap_table[new_seg_index].bounds[0] = (CELLPTR)ptr;
  304.   scm_heap_table[new_seg_index].bounds[1] = (CELLPTR)seg_end;
  305.  
  306.  
  307.   /* Compute the least valid object pointer w/in this segment 
  308.    */
  309.   ptr = CELL_UP (ptr);
  310.  
  311.  
  312.   n_new_objects = seg_end - ptr;
  313.  
  314.   /* Prepend objects in this segment to the freelist. 
  315.    */
  316.   while (ptr < seg_end)
  317.     {
  318. #ifdef POINTERS_MUNGED
  319.       scmptr = PTR2SCM (ptr);
  320. #endif
  321.       CAR (scmptr) = (SCM) tc_free_cell;
  322.       CDR (scmptr) = PTR2SCM (ptr + ncells);
  323.       ptr += ncells;
  324.     }
  325.  
  326.   ptr -= ncells;
  327.  
  328.   /* Patch up the last freelist pointer in the segment
  329.    * to join it to the input freelist.
  330.    */
  331.   CDR (PTR2SCM (ptr)) = *freelistp;
  332.   *freelistp = PTR2SCM (CELL_UP (seg_org));
  333.  
  334.   scm_heap_size += (ncells * n_new_objects);
  335.   return size;
  336. #ifdef scmptr
  337. #undef scmptr
  338. #endif
  339. }
  340.  
  341.  
  342. static char scm_s_nogrow[] = "could not grow";
  343. char scm_s_heap[] = "heap";
  344. static char scm_s_hplims[] = "hplims";
  345.  
  346. #ifdef __STDC__
  347. static void 
  348. alloc_some_heap (int ncells, SCM * freelistp)
  349. #else
  350. static void 
  351. alloc_some_heap (ncells, freelistp)
  352.      int ncells;
  353.      SCM * freelistp;
  354. #endif
  355. {
  356.   struct scm_heap_seg_data * tmptable;
  357.   CELLPTR ptr;
  358.   sizet len;
  359.  
  360.   /* Critical code sections (such as the garbage collector)
  361.    * aren't supposed to add heap segments.
  362.    */
  363.   if (scm_errjmp_bad)
  364.     scm_wta (SCM_UNDEFINED, "need larger initial", scm_s_heap);
  365.  
  366.   /* Expand the heap tables to have room for the new segment.
  367.    * Do not yet increment scm_n_heap_segs -- that is done by init_heap_seg
  368.    * only if the allocation of the segment itself succeeds.
  369.    */
  370.   len = (1 + scm_n_heap_segs) * sizeof (struct scm_heap_seg_data);
  371.  
  372.   SYSCALL (tmptable = ((struct scm_heap_seg_data *)
  373.                realloc ((char *)scm_heap_table, len)));
  374.   if (!tmptable)
  375.     scm_wta (SCM_UNDEFINED, scm_s_nogrow, scm_s_hplims);
  376.   else
  377.     scm_heap_table = tmptable;
  378.  
  379.  
  380.   /* Pick a size for the new heap segment.
  381.    * The rule for picking the size of a segment is explained in 
  382.    * (for some reason) setjump.h (c.f. {heap parameters}).
  383.    */
  384.   if (scm_expmem)
  385.     {
  386.       len = (sizet) (EXPHEAP (scm_heap_size) * sizeof (scm_cell));
  387.       if ((sizet) (EXPHEAP (scm_heap_size) * sizeof (scm_cell)) != len)
  388.     len = 0;
  389.     }
  390.   else
  391.     len = HEAP_SEG_SIZE;
  392.  
  393.   {
  394.     sizet smallest;
  395.  
  396.     smallest = (ncells * sizeof (scm_cell));
  397.     if (len < smallest)
  398.       len = (ncells * sizeof (scm_cell));
  399.  
  400.     /* Allocate with decaying ambition. */
  401.     while ((len >= MIN_HEAP_SEG_SIZE)
  402.        && (len >= smallest))
  403.       {
  404.     SYSCALL (ptr = (CELLPTR) malloc (len));
  405.     if (ptr)
  406.       {
  407.         init_heap_seg (ptr, len, ncells, freelistp);
  408.         return;
  409.       }
  410.     len /= 2;
  411.       }
  412.   }
  413.  
  414.   scm_wta (SCM_UNDEFINED, scm_s_nogrow, scm_s_heap);
  415. }
  416.  
  417.  
  418.  
  419.  
  420. #ifdef __STDC__
  421. void
  422. scm_permenant_object (SCM obj)
  423. #else
  424. void
  425. scm_permenant_object (obj)
  426.      SCM obj;
  427. #endif
  428. {
  429.   permobjs = scm_cons (obj, permobjs);
  430. }
  431.  
  432.  
  433.  
  434. /* {Object allocation}
  435.  */
  436.  
  437. /* scm_moderate_freelists
  438.  * is a table of freelists for object sizes less than SCM_MODERATE.
  439.  */
  440. #ifndef SCM_MODERATE
  441. #define SCM_MODERATE 256
  442. #endif
  443.  
  444. static SCM scm_moderate_freelists[SCM_MODERATE] = { (SCM)EOL };
  445.  
  446. /* scm_large_objects
  447.  * a circular, doubly linked list of large objects.
  448.  */
  449. static scm_cell scm_large_objects
  450. = { (SCM)&scm_large_objects, (SCM)&scm_large_objects };
  451.  
  452. struct large_obj_header
  453. {
  454.   scm_cell link;
  455.   int size;
  456. };
  457.  
  458. #ifdef __STDC__
  459. SCM
  460. scm_alloc_large (int ncells, char * reason)
  461. #else
  462. SCM
  463. scm_alloc_large (ncells, reason)
  464.      int ncells;
  465.      char * reason;
  466. #endif
  467. {
  468.   int bytes;
  469.   struct large_obj_header * mem;
  470.   SCM answer;
  471.  
  472.   bytes = (  (sizeof (scm_cell) * ncells)
  473.        + sizeof(struct large_obj_header));
  474.   mem = (struct large_obj_header *)scm_must_malloc (bytes, "large reason");
  475.   answer = (SCM)(mem + 1);
  476.  
  477.   DEFER_INTS;
  478.   CAR(answer) = (SCM)tc_free_cell;
  479.   CDR(answer) = (SCM)EOL;
  480.   ALLOW_INTS;
  481.  
  482.   {
  483.     int x;
  484.     for (x = 0; x < ncells; ++x)
  485.       ((SCM *)answer)[x] = BOOL_F;
  486.   }
  487.  
  488.   mem->size = bytes;
  489.  
  490.   mem->link.car = scm_large_objects.car;
  491.   mem->link.cdr = (SCM)&scm_large_objects;
  492.   CDR(mem->link.car) = (SCM)&(mem->link);
  493.   scm_large_objects.car = (SCM)&(mem->link);
  494.  
  495.   return answer;
  496. }
  497. #if 0
  498. #ifdef __STDC__
  499. static int
  500. free_large (SCM obj)
  501. #else
  502. static int
  503. free_large (obj)
  504.      SCM obj;
  505. #endif
  506. {
  507.   struct large_obj_header * mem;
  508.   mem = (struct large_obj_header *)obj;
  509.   mem -= 1;
  510.   CDR(mem->link.car) = mem->link.cdr;
  511.   CAR(mem->link.cdr) = mem->link.car;
  512.   {
  513.     int bytes;
  514.     bytes = mem->size;
  515.     scm_must_free ((char *)mem);
  516.     return bytes;
  517.   }
  518. }
  519. #endif
  520. /* {Malloc-like allocation for Scheme objects of aribitrary size}
  521.  * These can not be resized.
  522.  */
  523.  
  524. char scm_s_cells[] = "cells";
  525. #ifdef __STDC__
  526. void
  527. scm_gc_for_alloc (int ncells, SCM * freelistp)
  528. #else
  529. void
  530. scm_gc_for_alloc (ncells, freelistp)
  531.      int ncells;
  532.      SCM * freelistp;
  533. #endif
  534. {
  535.   REDEFER_INTS;
  536.   scm_igc (scm_s_cells);
  537.   REALLOW_INTS;
  538.   if ((scm_gc_cells_collected < MIN_GC_YIELD) || IMP (*freelistp))
  539.     {
  540.       REDEFER_INTS;
  541.       alloc_some_heap (ncells, freelistp);
  542.       REALLOW_INTS;
  543.       if (!scm_ints_disabled) /* !!! */
  544.     {
  545.           scm_growth_mon ("number of heaps", 
  546.               (long) scm_n_heap_segs, 
  547.               "segments");
  548.       scm_growth_mon (scm_s_heap, scm_heap_size, scm_s_cells);
  549.     }
  550.     }
  551. }
  552.  
  553. #ifdef __STDC__
  554. SCM
  555. scm_alloc_obj (SCM ncells, char * reason)
  556. #else
  557. SCM
  558. scm_alloc_obj (ncells, reason)
  559.      SCM ncells;
  560.      char * reason;
  561. #endif
  562. {
  563.   if (ncells > SCM_MODERATE)
  564.     return scm_alloc_large (ncells, reason);
  565.   else
  566.     {
  567.       SCM answer;
  568.       answer = scm_moderate_freelists[ncells];
  569.       if (answer == EOL)
  570.     scm_gc_for_alloc (ncells, &scm_moderate_freelists[ncells]);
  571.       answer = scm_moderate_freelists[ncells];
  572.       scm_moderate_freelists[ncells] = CDR (scm_moderate_freelists[ncells]);
  573.       return answer;
  574.     }
  575. }
  576.  
  577.  
  578. /* {Initialization for i/o and gc procedures.}
  579.  */
  580.  
  581. char scm_s_obunhash[] = "object-unhash";
  582.  
  583. #ifdef __STDC__
  584. void 
  585. scm_init_io (void)
  586. #else
  587. void 
  588. scm_init_io ()
  589. #endif
  590. {
  591. #ifndef CHEAP_CONTINUATIONS
  592.   scm_add_feature ("full-continuation");
  593. #endif
  594. }
  595.  
  596.  
  597. /* {cons pair allocation}
  598.  */
  599.  
  600. /* scm_freelist
  601.  * is the head of freelist of cons pairs.
  602.  */
  603. SCM scm_freelist = EOL;
  604.  
  605. /* scm_gc_for_newcell
  606.  *
  607.  * Still resides below under the PARADIGM ASSOCIATES copyright.
  608.  */
  609.  
  610.  
  611. /* {GC marking}
  612.  */
  613.  
  614. #ifdef __STDC__
  615. SCM 
  616. scm_markcdr (SCM ptr)
  617. #else
  618. SCM 
  619. scm_markcdr (ptr)
  620.      SCM ptr;
  621. #endif
  622. {
  623.   if (GC8MARKP (ptr))
  624.     return BOOL_F;
  625.   SETGC8MARK (ptr);
  626.   return CDR (ptr);
  627. }
  628.  
  629. #ifdef __STDC__
  630. SCM 
  631. scm_mark0 (SCM ptr)
  632. #else
  633. SCM 
  634. scm_mark0 (ptr)
  635.      SCM ptr;
  636. #endif
  637. {
  638.   SETGC8MARK (ptr);
  639.   return BOOL_F;
  640. }
  641.  
  642. #ifdef __STDC__
  643. sizet 
  644. scm_free0 (SCM ptr)
  645. #else
  646. sizet 
  647. scm_free0 (ptr)
  648.      SCM ptr;
  649. #endif
  650. {
  651.   return 0;
  652. }
  653.  
  654. #ifdef __STDC__
  655. SCM 
  656. scm_equal0 (SCM ptr1, SCM ptr2)
  657. #else
  658. SCM 
  659. scm_equal0 (ptr1, ptr2)
  660.      SCM ptr1;
  661.      SCM ptr2;
  662. #endif
  663. {
  664.   return (CDR (ptr1) == CDR (ptr2)) ? BOOL_T : BOOL_F;
  665. }
  666.  
  667.  
  668. /* statically allocated port for diagnostic messages */
  669. scm_cell scm_tmp_errp =
  670. {(SCM) ((0L << 8) | tc16_fport | OPN | WRTNG), 0};
  671.  
  672. static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
  673. extern sizet scm_num_protects;    /* scm_sys_protects now in scl.c */
  674.  
  675.  
  676. #ifdef __STDC__
  677. static void 
  678. fixconfig (char *s1, char *s2, int s)
  679. #else
  680. static void 
  681. fixconfig (s1, s2, s)
  682.      char *s1;
  683.      char *s2;
  684.      int s;
  685. #endif
  686. {
  687.   fputs (s1, stderr);
  688.   fputs (s2, stderr);
  689.   fputs ("\nin ", stderr);
  690.   fputs (s ? "setjump" : "scmfig", stderr);
  691.   fputs (".h and recompile scm\n", stderr);
  692.   scm_quit (MAKINUM (1L));
  693. }
  694.  
  695. int scm_take_stdin = 0;
  696.  
  697. #ifdef __STDC__
  698. void 
  699. scm_init_storage (SCM_STACKITEM *stack_start_ptr, long init_heap_size, FILE * in, FILE * out, FILE * err)
  700. #else
  701. void 
  702. scm_init_storage (stack_start_ptr, init_heap_size, in, out, err)
  703.      SCM_STACKITEM *stack_start_ptr;
  704.      long init_heap_size;
  705.      FILE * in;
  706.      FILE * out;
  707.      FILE * err;
  708. #endif
  709. {
  710.   sizet j = scm_num_protects;
  711.   /* Because not all protects may get initialized */
  712.   while (j)
  713.     scm_sys_protects[--j] = BOOL_F;
  714.   scm_tmp_errp.cdr = (SCM) stderr;
  715.   cur_errp = PTR2SCM (&scm_tmp_errp);
  716.   scm_freelist = EOL;
  717.   scm_expmem = 0;
  718.  
  719. #ifdef SINGLES
  720.   if (sizeof (float) != sizeof (long))
  721.       fixconfig (remsg, "SINGLES", 0);
  722. #endif /* def SINGLES */
  723. #ifdef BIGDIG
  724.   if (2 * BITSPERDIG / CHAR_BIT > sizeof (long))
  725.       fixconfig (remsg, "BIGDIG", 0);
  726. #ifndef DIGSTOOBIG
  727.   if (DIGSPERLONG * sizeof (BIGDIG) > sizeof (long))
  728.       fixconfig (addmsg, "DIGSTOOBIG", 0);
  729. #endif
  730. #endif
  731. #ifdef STACK_GROWS_UP
  732.   if (((STACKITEM *) & j - stack_start_ptr) < 0)
  733.     fixconfig (remsg, "STACK_GROWS_UP", 1);
  734. #else
  735.   if ((stack_start_ptr - (STACKITEM *) & j) < 0)
  736.     fixconfig (addmsg, "STACK_GROWS_UP", 1);
  737. #endif
  738.   j = HEAP_SEG_SIZE;
  739.   if (HEAP_SEG_SIZE != j)
  740.     fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);
  741.  
  742.   scm_mtrigger = INIT_MALLOC_LIMIT;
  743.   scm_heap_table = ((struct scm_heap_seg_data *)
  744.         scm_must_malloc (sizeof (struct scm_heap_seg_data),
  745.                  scm_s_hplims));
  746.   if (0L == init_heap_size)
  747.     init_heap_size = INIT_HEAP_SIZE;
  748.   j = init_heap_size;
  749.   if ((init_heap_size != j)
  750.       || !init_heap_seg ((CELLPTR) malloc (j), j, 1, &scm_freelist))
  751.     {
  752.       j = HEAP_SEG_SIZE;
  753.       if (!init_heap_seg ((CELLPTR) malloc (j), j, 1, &scm_freelist))
  754.     scm_wta (MAKINUM (j), (char *) NALLOC, scm_s_heap);
  755.     }
  756.   else
  757.     scm_expmem = 1;
  758.   scm_heap_org = CELL_UP (scm_heap_table[0].bounds[0]);
  759.   /* scm_hplims[0] can change. do not remove scm_heap_org */
  760.  
  761.   /* Initialise the list of ports.  */
  762.   scm_port_table = (struct scm_port_table *)
  763.     scm_must_malloc ((long) (sizeof (struct scm_port_table)
  764.              * scm_port_table_room),
  765.              "port list");
  766.   /* Initialise standard ports.  */
  767.   NEWCELL (def_inp);
  768.   if (scm_take_stdin && !in)
  769.     in = stdin;
  770.   if (in)
  771.     {
  772.       CAR (def_inp) = (tc16_fport | OPN | RDNG);
  773.       SETSTREAM (def_inp, in);
  774.       if (isatty (fileno (in)))
  775.     {
  776.       scm_setbuf0 (def_inp);        /* turn off stdin buffering */
  777.       CAR (def_inp) |= BUF0;
  778.     }
  779.       scm_add_to_port_table (def_inp);
  780.       scm_set_port_revealed_x (def_inp, MAKINUM (1));
  781.     }
  782.   else
  783.     {
  784.       SCM str;
  785.       str = scm_makfromstr ("", 0, 0);
  786.       CAR (def_inp) = (tc16_strport | OPN | RDNG);
  787.       SETCHARS (def_inp, str);
  788.     }
  789.   if (!out)
  790.     out = stdout;
  791.   NEWCELL (def_outp);
  792.   CAR (def_outp) = (tc16_fport | OPN | WRTNG);
  793.   SETSTREAM (def_outp, out);
  794.   scm_add_to_port_table (def_outp);
  795.   scm_set_port_revealed_x (def_outp, MAKINUM (1));
  796.   NEWCELL (def_errp);
  797.   if (!err)
  798.     err = stderr;
  799.   CAR (def_errp) = (tc16_fport | OPN | WRTNG);
  800.   SETSTREAM (def_errp, err);
  801.   scm_add_to_port_table (def_errp);
  802.   scm_set_port_revealed_x (def_errp, MAKINUM (1));
  803.   cur_inp = def_inp;
  804.   cur_outp = def_outp;
  805.   cur_errp = def_errp;
  806.   dynwinds = EOL;
  807.   NEWCELL (rootcont);
  808.   SETJMPBUF (rootcont, scm_must_malloc ((long) sizeof (regs), "continuation"));
  809.   CAR (rootcont) = tc7_contin;
  810.   DYNENV (rootcont) = EOL;
  811.   BASE (rootcont) = stack_start_ptr;
  812.   listofnull = scm_cons (EOL, EOL);
  813.   undefineds = scm_cons (SCM_UNDEFINED, EOL);
  814.   CDR (undefineds) = undefineds;
  815.   nullstr = scm_makstr (0L, 0);
  816.   nullvect = scm_make_vector (INUM0, SCM_UNDEFINED);
  817.   /* NEWCELL(nullvect);
  818.        CAR(nullvect) = tc7_vector;
  819.        SETCHARS(nullvect, NULL); */
  820.   symhash = scm_make_vector ((SCM) MAKINUM (scm_symhash_dim), EOL);
  821.   symhash_vars = scm_make_vector ((SCM) MAKINUM (scm_symhash_dim), EOL);
  822.   scm_sysintern ("most-positive-fixnum", (SCM) MAKINUM (MOST_POSITIVE_FIXNUM));
  823.   scm_sysintern ("most-negative-fixnum", (SCM) MAKINUM (MOST_NEGATIVE_FIXNUM));
  824.   scm_sysintern ("*stdin*", def_inp);
  825.   scm_sysintern ("*stdout*", def_outp);
  826.   scm_sysintern ("*stderr*", def_errp);
  827. #ifdef BIGDIG
  828.   scm_sysintern ("bignum-radix", MAKINUM (BIGRAD));
  829. #endif
  830.   /* flo0 is now setup in scl.c */
  831.   scm_bad_throw_vcell = scm_sysintern ("%%bad-throw", BOOL_F);
  832. }
  833.  
  834.  
  835. struct array
  836. {
  837.   struct array * next;
  838.   struct array * prev;
  839.   int size;
  840.   SCM elts[1];
  841. };
  842.  
  843.  
  844. static struct array * arrays;
  845.  
  846. /* Not safely interrupted. */
  847. #ifdef __STDC__
  848. SCM *
  849. scm_mkarray (int size, int fillp)
  850. #else
  851. SCM *
  852. scm_mkarray (size, fillp)
  853.      int size;
  854.      int fillp;
  855. #endif
  856. {
  857.   struct array * answer;
  858.   answer = (struct array *)malloc (sizeof (*answer) + size * sizeof(SCM));
  859.   if (!answer)
  860.     return 0;
  861.   answer->size = size;
  862.   if (fillp)
  863.     {
  864.       int x;
  865.       for (x = 0; x < size; ++x)
  866.     answer->elts[x] = BOOL_F;
  867.     }
  868.   if (!arrays)
  869.     {
  870.       arrays = answer;
  871.       answer->next = answer->prev = answer;
  872.     }
  873.   else
  874.     {
  875.       answer->next = arrays;
  876.       answer->prev = arrays->prev;
  877.       answer->next->prev = answer;
  878.       answer->prev->next = answer;
  879.     }
  880.  
  881.   return answer->elts;
  882. }
  883.  
  884.  
  885. /* Not safely implemented */
  886. #ifdef __STDC__
  887. void
  888. scm_free_array (SCM * elts)
  889. #else
  890. void
  891. scm_free_array (elts)
  892.      SCM * elts;
  893. #endif
  894. {
  895.   struct array * it;
  896.   it = (struct array *) ((char *)elts - (int)(&((struct array *)0)->elts));
  897.   if (it == arrays)
  898.     {
  899.       if (it == it->next)
  900.     arrays = 0;
  901.       else
  902.     arrays = it->next;
  903.     }
  904.   it->next->prev = it->prev;
  905.   it->prev->next = it->next;
  906.   free ((char *)it);
  907. }
  908.  
  909.  
  910. #ifdef __STDC__
  911. void
  912. scm_mark_arrays (void)
  913. #else
  914. void
  915. scm_mark_arrays ()
  916. #endif
  917. {
  918.   struct array * pos;
  919.   pos = arrays;
  920.   if (!pos)
  921.     return;
  922.   do
  923.     {
  924.       int x;
  925.       int size;
  926.       SCM * elts;
  927.       size = pos->size;
  928.       elts = pos->elts;
  929.       for (x = 0; x < size; ++x)
  930.     scm_gc_mark (elts[x]);
  931.       pos = pos->next;
  932.     } while (pos != arrays);
  933. }
  934.  
  935.  
  936. PROC (s_object_address, "object-address", 1, 0, 0, scm_object_addr);
  937. SCM
  938. scm_object_addr (obj)
  939.      SCM obj;
  940. {
  941.   return scm_ulong2num ((unsigned long)obj);
  942. }
  943.  
  944. PROC (s_gc, "gc", 0, 0, 0, scm_gc);
  945. #ifdef __STDC__
  946. SCM 
  947. scm_gc (void)
  948. #else
  949. SCM 
  950. scm_gc ()
  951. #endif
  952. {
  953.   DEFER_INTS;
  954.   scm_igc ("call");
  955.   ALLOW_INTS;
  956.   return UNSPECIFIED;
  957. }
  958.  
  959.  
  960. #ifdef __STDC__
  961. void
  962. scm_remember (SCM * ptr)
  963. #else
  964. void
  965. scm_remember (ptr)
  966.      SCM * ptr;
  967. #endif
  968. {}
  969.  
  970.  
  971.  
  972.  
  973. #ifdef __STDC__
  974. void
  975. scm_init_gc (void)
  976. #else
  977. void
  978. scm_init_gc ()
  979. #endif
  980. {
  981. #include "gc.x"
  982. }
  983.  
  984. /* See "marksweep.c" */
  985.